home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / PRG / PowerLisp 2.01 FAT Folder.sit / PowerLisp 2.01 FAT Folder / PowerLisp 2.01 ƒ / Library / compiler_ppc.lisp < prev    next >
Lisp/Scheme  |  1996-05-22  |  62KB  |  2,272 lines
  1. ;;;
  2. ;;;        PowerLisp 2.0
  3. ;;;        Copyright ｩ 1996 Roger Corman.  All rights reserved.
  4. ;;;        PowerPC Compiler source
  5. ;;;
  6.  
  7. ;
  8. ;    Source code for compiler.
  9. ;    This is included in the "COMPILER" package.
  10. ;
  11.  
  12. (eval-when (:compile-toplevel :load-toplevel :execute)
  13.     (provide :compiler)
  14.     (in-package :compiler)
  15.     (require :assembler)
  16.     (use-package :assembler)
  17.     (export '(compiler::compile-top-level-form)))
  18.  
  19. (eval-when (:compile-toplevel :load-toplevel :execute)
  20.     (defun assembly-start (stream char)
  21.         (cons 'compiler::push-assembly-instructions (read-delimited-list #¥] stream)))
  22.     (defun assembly-end (stream char) nil)
  23.     (set-macro-character #¥[ #'assembly-start)
  24.     (set-macro-character #¥] #'assembly-end))
  25.  
  26. ;
  27. ;    We do an eval-when on the entire file so that we get the
  28. ;    performance benefits immediately
  29. ;
  30. (eval-when (:compile-toplevel :load-toplevel :execute)
  31.     
  32. (defvar *assemble-code* t)
  33. (defvar *asm* nil)
  34. (defvar *lex-counter* 0)
  35. (defvar *references* nil)
  36. (defvar *function-name* nil)
  37. (defvar *function-entry-label* nil)
  38. (defvar *cleanup-forms-stack* nil)
  39. (defvar *lambda-list* nil)
  40. (defvar *arg-count* 0)
  41. (defvar *last-call-was-values* nil)
  42. (defvar *returned-multiple-values* nil)
  43. (defvar *environment* nil)
  44. (defvar *embedded-lambdas* nil)
  45. (defvar *lambda-special-vars* nil)
  46. (defvar *lambda-declarations* nil)
  47. (defvar *lambda-special-decs* nil)
  48. (defvar *compile-time-too-mode* nil) 
  49. (defvar *compile-print* nil)
  50. (defvar *compile-output-file* nil)
  51. (defvar *symbol-table* nil)
  52. (defvar *last-call-was-tail-recursion* nil)
  53. (defvar *max-call-parameters* 6)
  54. (defvar *current-call-index* 0)
  55. (defconstant *jmp_buf-size* 70)            ;; 70 longs are stored
  56.  
  57. ;; top level forms which we will output the names of while compiling
  58. ;; if *compile-print* is true
  59. (defvar *compiler-print-forms* 
  60.     '(defun defmacro defstruct defclass defvar defparameter defconstant))
  61.  
  62. (defun compile-it (name &optional lambda &aux (macro nil))
  63.     (unless (typep name 'symbol) (error "Function name expected"))
  64.     (unless lambda (setf lambda (function-definition (symbol-function name))))
  65.     (setq macro (macro-function name))
  66.     (unless (eq (car lambda) 'lambda) (error "Not a lambda expression"))
  67.     (setq *assemble-code* t)
  68.     (if macro
  69.         (setf (macro-function name) (compile-lambda lambda name))
  70.         (setf (symbol-function name) (compile-lambda lambda name)))
  71.     name)
  72.  
  73. (defun compile-without-assembling-it (name &optional lambda &aux (macro nil))
  74.     (unless (typep name 'symbol) (error "Function name expected"))
  75.     (unless lambda (setf lambda (function-definition (symbol-function name))))
  76.     (setq macro (macro-function name))
  77.     (unless (eq (car lambda) 'lambda) (error "Not a lambda expression"))
  78.     (setq *assemble-code* nil)
  79.     (compile-lambda lambda name))
  80.  
  81. (defun compile-the-file (input-file output-file print)
  82.     (setq *assemble-code* t)
  83.     (do* ((infile (open input-file :direction :input)) 
  84.           (*compile-output-file* 
  85.                 (progn 
  86.                     (delete-file output-file) 
  87.                     (open output-file 
  88.                         :direction :output 
  89.                         :if-exists :overwrite
  90.                         :if-does-not-exist :create)))
  91.           (*compile-print* print)
  92.           (*package* *package*)
  93.           (*readtable* *readtable*)
  94.           (*symbol-table* (make-hash-table :size 500))
  95.           (input-expression (read infile nil 'Eof nil) (read infile nil 'Eof nil))
  96.           code
  97.           return-value)
  98.          ((eq input-expression 'Eof) 
  99.             (close infile)
  100.             (set-file-type *compile-output-file* "FASL")
  101.             (close *compile-output-file*)
  102.             output-file)
  103.         
  104.         (process-top-level-forms (list input-expression))))
  105.  
  106. ;;
  107. ;;    The following logic is taken from CLTL2 pp.90-91
  108. ;;
  109. (defun process-top-level-forms (forms &aux code return-value print-form)
  110.     (dolist (f forms)
  111.         (setq print-form nil)
  112.         (if (not (consp f)) (go continue))    ;; no need to process non-list forms
  113.             
  114.         (if (and *compile-print*
  115.                 (member (car f) *compiler-print-forms*) 
  116.                 (consp (cdr f)))
  117.             (setq print-form (list (car f) (cadr f) "...")))
  118.  
  119. ;        (format t "print-form = ~A~%" print-form)
  120. ;        (file-flush)
  121.  
  122.         (if (macro-function (car f)) ;; if it is a macro expand it
  123.             (progn
  124.                 (setq f (macroexpand f))
  125.                 (if (not (consp f)) (go continue)))) ;; no need to process non-list forms
  126.  
  127.         ;; watch for some special forms
  128.         (if (special-form-p (car f))
  129.  
  130.             (progn
  131.                 ;; if a progn or locally special form, recurse
  132.                 (if (or (eq (car f) 'common-lisp::progn) 
  133.                         (eq (car f) 'common-lisp::locally))
  134.                     (progn
  135.                         (process-top-level-forms (cdr f))
  136.                         (go continue)))
  137.  
  138.                 ;; if compiler-let, macrolet or symbol-macrolet
  139.                 (if (or (eq (car f) 'common-lisp::compiler-let)
  140.                         (eq (car f) 'common-lisp::macrolet)  
  141.                         (eq (car f) 'common-lisp::symbol-macrolet))
  142.                     (progn
  143.                         (error "Compiler does not support special form: ~A" (car f))
  144.                         (process-top-level-forms (cdr f))
  145.                         (go continue)))
  146.     
  147.                 ;; if eval-when
  148.                 (if (eq (car f) 'common-lisp::eval-when)
  149.                     (progn
  150.                         (compile-top-level-eval-when-form f)
  151.                         (go continue)))))
  152.  
  153.         ;; else it is not a special case
  154.  
  155.         ;; now compile it
  156.         (setq code (compile-top-level-form f))
  157.         (%write-code-to-stream code *compile-output-file* *symbol-table*)
  158.  
  159.         ;; evaluate the form if compile-time-too mode
  160.         (if *compile-time-too-mode*
  161.             (setq return-value (funcall code)))
  162.  
  163. continue
  164.         (if print-form
  165.              (progn
  166.                 (format t "~A~%" print-form)
  167.                 (file-flush)))))
  168.  
  169. (defun compile-top-level-eval-when-form (form)
  170.     (if (or (not (consp form)) (< (length form) 2) (not (listp (cadr form))))
  171.         (error "'eval-when' form missing condition list."))
  172.  
  173.     (let* ((conditions (cadr form))
  174.            (load-condition 
  175.             (or (member 'common-lisp::load conditions) 
  176.                 (member :load-toplevel conditions)))
  177.            (eval-condition 
  178.             (or (member 'common-lisp::eval conditions) 
  179.                 (member :execute conditions)))
  180.            (compile-condition 
  181.             (or (member 'common-lisp::compile conditions) 
  182.                 (member :compile-toplevel conditions))))
  183.  
  184.         (if load-condition
  185.             (if (or compile-condition 
  186.                     (and *compile-time-too-mode* eval-condition))
  187.                 (let ((*compile-time-too-mode* t))
  188.                     (process-top-level-forms (cddr form)))
  189.                 (let ((*compile-time-too-mode* nil))
  190.                     (process-top-level-forms (cddr form))))
  191.  
  192.             ;; load not specified
  193.             (if (or compile-condition 
  194.                     (and *compile-time-too-mode* eval-condition))
  195.                 (eval form)))))            
  196.     
  197. ;;
  198. ;;    The cleanup forms stack needs to be maintained for use in non-local
  199. ;;    lexically scoped exit situations. Specifically, GO with a target outside
  200. ;;    the current construct, and RETURN-FROM when exiting an external construct.
  201. ;;    Note that THROW targets are dynamic, not lexical, and therefore cannot
  202. ;;    be handled at compile time. They are handled via a different mechanism, a
  203. ;    run-time stack. Lexically scoped exits are better handled at compile time,
  204. ;;    both for efficiency (a big concern, because GO is the primary iteration 
  205. ;;    facility) and because the lexical scoping is currently only known at
  206. ;;    compile-time. In other words, a run-time lexical environment is not maintained
  207. ;;    for compiled code, and for efficiency reasons it would be better not to have
  208. ;;    to.
  209. ;;
  210. ;;    Entries on the cleanup forms stack include:
  211. ;;
  212. ;;    (BLOCK block-name block-exit-label)
  213. ;;    (TAGBODY (local-tag-1 . local-label-1) (local-tag-2 . local-label-2) ...)
  214. ;;    (LET (local-var-1 . index1) (local-var-2 . index2) ...)
  215. ;;        (the LET form is used by both LET *and* LET* forms)
  216. ;;    (CATCH catch-tag)
  217. ;;    (UNWIND-PROTECT <compiled code to be included>)
  218. ;; 
  219.  
  220. (defconstant *lambda-list-keywords* 
  221.         '(    &optional 
  222.             &rest 
  223.             &key 
  224.             &aux 
  225.             &allow-other-keys
  226.             &whole
  227.             &body ))
  228.  
  229. ;; the following aren't allowed in lambda function declarations
  230. ;; (only in macros, which will be expanded before we see them)
  231. (defconstant *unsupported-lambda-list-keywords* 
  232.         '(  &whole
  233.             &body ))
  234.  
  235. (defparameter *num-saved-registers* 6)
  236. (defparameter *saved-register-bytes* (* *num-saved-registers* 4))
  237. (defparameter *linkage-bytes* 24)
  238. (defparameter *standard-reg-bytes* (* 8 4))            ;; space to save r3-r10
  239. (defparameter *fixed-linkage-bytes*
  240.     (+ *saved-register-bytes* *linkage-bytes* *standard-reg-bytes*))
  241.  
  242. ;;
  243. ;;    Set up square braces as assembly delimiters for this module
  244. ;;    This helps to clearly distinguish the generated code from the
  245. ;;    surrounding stuff.
  246. ;;
  247. (defun push-assembly-instructions (&rest instructions)
  248.     (dolist (x instructions)
  249.         (push x *asm*)))
  250.  
  251. (defun push-cleanup (x) (push x *cleanup-forms-stack*))
  252. (defun pop-cleanup () (pop *cleanup-forms-stack*))
  253.  
  254. ;;    We use the following registers:
  255. ;;    R0  : scratch register
  256. ;;    R3  : stores returned value
  257. ;;    R26 : temporary variable
  258. ;;    R27 : pointer to function's parameters
  259. ;;    R28 : used to keep current return value
  260. ;;    R29 : points to parameter area for calls we make
  261. ;;    R30 : points to lexical storage for the function
  262. ;;    R31 : points to function's environment (variables with indefinite extent)
  263. ;;    
  264. ;;    We do not need to save R0 or R3
  265. ;;    We *do* need to save R11 - R14.
  266. ;;
  267.             
  268. ;;
  269. ;;    compile-top-level-form (form &optional (assemble t))
  270. ;;    Given an arbitrary lisp form, returns a compiled function 
  271. ;;    equivalent to it.
  272. ;;
  273. (defun compile-top-level-form (form)
  274.     (let* (
  275.            ;; Establish local bindings of these special variables
  276.            ;; so that this function can be entered recursively.
  277.            ;;
  278.            (*asm* nil)
  279.            (*lex-counter* 0)
  280.            (*references* nil)
  281.            (*function-entry-label* (gensym))
  282.            (*last-call-was-values* nil)
  283.            (*returned-multiple-values* nil)
  284.            (*cleanup-forms-stack* nil)
  285.            (*environment* nil)
  286.            (*max-call-parameters* 6)            
  287.            (*current-call-index* 0)
  288.            (*embedded-lambdas* (find-lambdas form)))    
  289.            
  290.         ;; emit code for function prolog
  291.         (emit-prolog)
  292.                 
  293.         ;; compile the form
  294.         (compile-form form)
  295.  
  296.         ;; make sure bogus multiple values don't get returned
  297.         (unless (or *last-call-was-values* *returned-multiple-values*)
  298.             (kill-multiple-values))
  299.  
  300.         (emit-epilog)        
  301.         
  302.         ;; if we don't want to assemble it, exit here
  303.         (if *assemble-code* 
  304.             (return (assemble *asm* *references* nil))            
  305.             (return *asm*))))
  306.  
  307.  
  308. ;;---------------------------------------------------
  309. ;;
  310. ;;    compile-lambda (lambda)
  311. ;;    Given a lambda expression, returns a compiled function.
  312. ;;
  313. (defun compile-lambda (lambda func-name)
  314.     (check-lambda lambda)            ;; make sure we can compile it    
  315.     (let* ((*asm* nil)
  316.            (*references* nil)
  317.            (*function-name* func-name)
  318.            (*function-entry-label* (gensym))
  319.            (*cleanup-forms-stack* nil)
  320.            (*lambda-list* (cadr lambda))
  321.            (*last-call-was-values* nil)
  322.            (*returned-multiple-values* nil)
  323.            (*environment* *environment*)    ;; inherit from enclosing expression
  324.            (*embedded-lambdas* (find-lambdas (cdr lambda)))    
  325.            (*arg-count* 0)
  326.            (*lex-counter* 0)
  327.            (*lambda-special-vars* nil)
  328.            (*lambda-declarations* nil)            
  329.            (*lambda-special-decs* nil)
  330.            (*last-call-was-tail-recursion* nil)
  331.            (*max-call-parameters* 6)            
  332.            (*current-call-index* 0)
  333.            (forms (cddr lambda))
  334.            (new-vars (collect-new-vars *lambda-list*))
  335.            (lex-vars nil)
  336.            (aux-args (aux-arguments *lambda-list*)))
  337.  
  338.         ;; look for declarations
  339.         (do ((f forms (cdr f)))
  340.             ((null f) (setq forms f))
  341.             (if (and (consp (car f)) (eq (caar f) 'declare))
  342.                 (push (car f) *lambda-declarations*)
  343.                 (progn (setq forms f) (return))))
  344.  
  345.         ;; search declarations for special declarations
  346.         (dolist (declaration *lambda-declarations*)
  347.             (dolist (dec-form (cdr declaration))
  348.                 (if (and (consp dec-form) (eq (car dec-form) 'special))
  349.                     (setq *lambda-special-decs*
  350.                         (append (cdr dec-form) *lambda-special-decs*)))))
  351.  
  352.         (setq lex-vars 
  353.             (remove-if 
  354.                 #'(lambda (x) 
  355.                     (or (member x *lambda-special-decs*)
  356.                         (special-variable-p x)))
  357.                 new-vars
  358.                 :key #'car))
  359.  
  360.         (add-lexical-variables lex-vars)
  361.  
  362.         (emit-prolog)
  363.         (compile-lambda-args)
  364.         (create-runtime-bindings)    ;; create necessary heap bindings
  365.         
  366.         ;; handle aux variables by just adding an implicit let* form
  367.         (if aux-args
  368.             (setf forms `((let* ,aux-args ,@forms))))
  369.             
  370.         (compile-nil)        ;; store NIL as default return value
  371.                 
  372.  
  373.         (if *lambda-special-vars*
  374.             (compile-unwind-protect-form 
  375.                 `(unwind-protect 
  376.                     (block ,func-name ,@forms)
  377.                     ($pop-special-bindings ',*lambda-special-vars*)))
  378.  
  379.             ;; else execute the forms directly
  380.             ;; compile the forms as a block
  381.             (compile-block-form `(block ,func-name ,@forms)))
  382. #|
  383.         ;; eliminate tail recursion
  384.         (if nil ;; *last-call-was-tail-recursion*
  385.             (let* ((num-call-instructions (- (length *asm*) (length *last-call-was-tail-recursion*)))
  386.                    (call-instructions (reverse (subseq *asm* 0 num-call-instructions)))
  387.                    (find-top-label (gensym))
  388.                    (copy-label))
  389.  
  390.                 ;; strip off the function call
  391.                 (setq *asm* *last-call-was-tail-recursion*)
  392.  
  393.                 ;; push all instructions up to the bsr
  394.                 (do ((inst (pop call-instructions) (pop call-instructions)))
  395.                     ((or (null call-instructions) 
  396.                         (and (consp inst) (eq (car inst) 'assembler::bsr))))
  397.                     (push inst *asm*))
  398.  
  399.                 ;; move passed params to outer stack frame
  400.                 ;; add return address and branch instruction to simulate jsr
  401.                 [
  402.                     `(move.l a7 a3)
  403.                     
  404.                     ;; position a3 above top of parameter frame
  405.                     find-top-label        
  406.                     `(tst.l (a3+))
  407.                     `(bne ,find-top-label)
  408.  
  409.                     ;; copy parameters
  410.                     copy-label
  411.                     `(move.l (-a3) (-a2))
  412.                     `(move.l a3 d0)            ;; haven't implemented cmpa.l instruction yet
  413.                     `(cmp.l a7 d0)
  414.                     `(bne ,copy-label)
  415.                     `(unlk a6)
  416.                     `(move.l (a7) a0)            ; get return address in a0
  417.                     `(lea (a2 4) a7)
  418.                     `(move.l a7 (-a7))
  419.                     `(move.l a0 (-a7))
  420.                     `(bra ,*function-entry-label*)
  421.                 ]
  422.                 
  423.                 ;; add the rest of the instructions
  424.                 (do ((inst (pop call-instructions) (pop call-instructions)))
  425.                     ((null call-instructions)) 
  426.                     (push inst *asm*))))
  427. |#                
  428.         ;; make sure bogus multiple values don't get returned
  429.         (unless (or *last-call-was-values* *returned-multiple-values*)
  430.             (kill-multiple-values))
  431.  
  432.         (emit-epilog)
  433.         (pop-cleanup)        
  434.         (if *assemble-code* 
  435.             (return (assemble *asm* *references* nil))            
  436.             (return *asm*))))
  437.  
  438.  
  439. (defun compile-lambda-args ()
  440.     (compile-lambda-required-args)
  441.     (compile-lambda-optional-args)
  442.     (compile-lambda-rest-args)        
  443.     (check-no-more-args)
  444.     (compile-lambda-key-args))
  445.     
  446.  
  447. (defun collect-new-vars (lambda-list)
  448.     (let ((new-vars nil)(supplied_p_vars nil))
  449.         (dolist (n lambda-list)                    ;; add lexical vars
  450.             (if (not (member n *lambda-list-keywords*))
  451.                 (progn
  452.                     (if (consp n)
  453.                         (progn
  454.                             (if (>= (length n) 3)        ;; get supplied_p symbols
  455.                                 (push (caddr n) supplied_p_vars))
  456.                             (push (cons (car n) *lex-counter*) new-vars))
  457.                         (push (cons n *lex-counter*) new-vars))
  458.                     (incf *lex-counter*))))
  459.         (dolist (n supplied_p_vars)
  460.             (push (cons n *lex-counter*) new-vars)    ;; these need to go on the end
  461.             (incf *lex-counter*))
  462.         (nreverse new-vars)))                        
  463.  
  464.  
  465. ;; emit code for start of function            
  466. (defun emit-prolog ()
  467. ;;    [ 
  468. ;;        `(mflr r0)
  469. ;;        `(stw r0 (sp 8))                ; store link register on stack
  470. ;;        `(stmw r27, -20(SP))            ; save R27 - R31 on stack
  471. ;;        `(stwu sp (sp ,(- (+ 20 24 ???(* *lex-counter* 4)))))
  472. ;;    ]
  473.  
  474.     (if (or *embedded-lambdas* (environment-not-empty))
  475.     [
  476.         `(bl 4)                            ; put current pc in link register
  477.         `(mflr r4)                        ; r0 = pc
  478.         `(addi r31 r4 -28)        
  479.         `(lwz r31 (r31))                ; r31 = pointer to environment (just before code)
  480.     ])
  481.     
  482.     [
  483.         `(mr r27 r3)                    ; r27 = pointer to parameters - 4
  484.         `(addi r27 r27 -4)
  485.         `(addi r30 sp 
  486.             ,(+ *standard-reg-bytes* *linkage-bytes*))    ; set up local storage pointer 
  487.     ])
  488.  
  489.  
  490. ;; emit code for end of function            
  491. (defun emit-epilog ()
  492.     (let* ((lex-bytes (* (+ *lex-counter* *max-call-parameters*) 4))
  493.           (var-bytes (* *lex-counter* 4))
  494.           (frame-size (+ *fixed-linkage-bytes* lex-bytes)))
  495.         [
  496.             `(mr r3 r28)                    ; return value in r3
  497.             `(addi sp sp ,frame-size)         ; restore stack
  498.             `(lmw r26 (sp ,(- *saved-register-bytes*)))    ; restore register R26-R31
  499.             `(lwz r0 (sp 8))
  500.             `(mtlr r0)
  501.             `(blr)
  502.         ]
  503.     
  504.         (setq *asm* (nreverse *asm*))
  505.  
  506.         ;; These last instructions get pushed onto the beginning
  507.         ;; of the (now-reversed) instructions. Therefore they are reversed
  508.         ;; here to come out in the right order.
  509.         [
  510.             `(addi r29 sp ,(+ *standard-reg-bytes* *linkage-bytes* var-bytes))     ;; set up param area
  511.             `(stwu sp (sp ,(- frame-size)))    ; allocate stack space
  512.             `(stmw r26 (sp ,(- *saved-register-bytes*)))    ; save R26 - R31 on stack
  513.             `(stw r0 (sp 8))                ; store link register on stack
  514.             `(mflr r0)
  515.             *function-entry-label*
  516.         ]))    
  517.  
  518. ;; Make sure there are no more arguments.
  519. (defun check-no-more-args ()
  520.     (if (not (or (rest-arguments *lambda-list*) (key-arguments *lambda-list*)))
  521.         [
  522.             `(lwzu r3 (r27 4))                    ; get argument
  523.             `($CALL #'common-lisp::%checkNull)     ; signal error if extra argument
  524.         ]))
  525.  
  526. ;;
  527. ;;    compile-lambda-required-args
  528. ;;    Generates code to initialize required argumensts.
  529. ;;
  530. (defun compile-lambda-required-args ()
  531.     (dolist (sym (required-arguments *lambda-list*))
  532.         [
  533.             `(lwzu r3 (r27 4))                ; get argument
  534.             `($CALL #'common-lisp::%checkObj) ; signal error if argument missing
  535.             `(stw r3 (r30 ,(* *arg-count* 4)))
  536.         ]
  537.         
  538.         (if (or (special-variable-p sym) (member sym *lambda-special-decs*))
  539.             (let ((counter *current-call-index*))
  540.                 (parameter-ceiling (+ counter 3))  
  541.                 (push sym *lambda-special-vars*)
  542.                 [
  543.                     `($LOAD-OBJ r3 ',sym)
  544.                     `(stw r3 (r29 ,(* counter 4)))  
  545.                     `(lwz r0 (r30 ,(* *arg-count* 4)))
  546.                     `(stw r0 (r29 ,(* (+ counter 1) 4)))  
  547.                     `(li r3 0)
  548.                     `(stw r3 (r29,(* (+ counter 2) 4)))
  549.                     `(addi r3 r29 ,(* *current-call-index* 4))
  550.                     `($CALL #'common-lisp::$push-special-bindings)
  551.                 ]))
  552.  
  553.         (incf *arg-count*)))
  554.  
  555.  
  556. ;;
  557. ;;    compile-lambda-optional-args
  558. ;;    Generates code to initialize optional argumensts.
  559. ;;
  560. (defun compile-lambda-optional-args () nil)
  561. (defun compile-lambda-rest-args () nil)
  562. (defun compile-lambda-key-args () nil)
  563.  
  564. (defun compile-lambda-optional-args ()
  565.     (dolist (sym (optional-arguments *lambda-list*))
  566.         ;; initialize optional variable
  567.         (let ((else-label (gensym)) 
  568.                 (end-label (gensym)))
  569.             [
  570.                 `(lwz r3 (r27 4))            ;; is there an argument
  571.                 `(cmpwi r3 0)
  572.                 `(beq ,else-label)
  573.             ]
  574.             (if (and (consp sym) (>= (length sym) 3))
  575.                 (compile-form `(setq ,(caddr sym) t)))    ;; set supplied_p
  576.             [ 
  577.                 `(lwzu r3 (r27 4))            ;; is there an argument
  578.                 `(stw r3 (r30 ,(* *arg-count* 4)))
  579.                 `(b ,end-label)
  580.                 else-label
  581.             ]
  582.                 
  583.             ;; else do default initialization
  584.  
  585.             (if (and (consp sym) (>= (length sym) 3))
  586.                 (compile-form `(setq ,(caddr sym) nil)))    ;; set supplied_p
  587.  
  588.             (if (and (consp sym) (cdr sym))
  589.                 (progn
  590. ;;                    [
  591. ;;                        `(movem.l    a0 a2 a3 d0 (-a7))
  592. ;;                    ]
  593.                     (compile-form (cadr sym))
  594.                     [
  595. ;;                        `(movem.l (a7+) a0 a2 a3 d0)
  596.                         `(stw r28 (r30 ,(* *arg-count* 4)))
  597.                     ])
  598.                 ;; else
  599.                 [
  600.                     `($LOAD-OBJ r3 'nil)
  601.                     `(stw r3 (r30 ,(* *arg-count* 4)))
  602.                 ])
  603.             [
  604.                 end-label
  605.             ])
  606.  
  607.         (if (or (special-variable-p sym) (member sym *lambda-special-decs*))
  608.             (let ((counter *current-call-index*))
  609.                 (parameter-ceiling (+ counter 3))
  610.                 (push sym *lambda-special-vars*)
  611.                 [
  612.                     `($LOAD-OBJ r3 ',sym)
  613.                     `(stw r3 (r29 ,(* counter 4)))                        
  614.                     `(lwz r3 (r30 ,(* *arg-count* 4)))
  615.                     `(stw r3 (r29 ,(* (+ counter 1) 4)))
  616.                     `(li r3 0)
  617.                     `(stw r3 (r29 ,(* (+ counter 2) 4)))                        
  618.                     `(addi r3 r29 ,(* *current-call-index* 4))
  619.                     `($CALL #'cl::$push-special-bindings)
  620.                 ]))
  621.             
  622.         (incf *arg-count*)))
  623.  
  624.  
  625. ;;
  626. ;;    compile-lambda-rest-args
  627. ;;    Generates code to initialize rest arguments.
  628. ;;    We allow more than one.
  629. ;;
  630. (defun compile-lambda-rest-args ()
  631.     (let* ((rest-args (rest-arguments *lambda-list*)))
  632.         (if rest-args
  633.             [
  634.                 `(addi r3 r27 4)
  635.                 `($CALL #'list)
  636.             ])
  637.         (dolist (sym rest-args)
  638.             [
  639.                 `(stw r3 (r30 ,(* *arg-count* 4)))
  640.             ]
  641.         
  642.         (if (or (special-variable-p sym) (member sym *lambda-special-decs*))
  643.                 (let ((counter *current-call-index*)) 
  644.                     (parameter-ceiling (+ counter 3))
  645.                     (push sym *lambda-special-vars*)
  646.                     [
  647.                         `($LOAD-OBJ r3 ',sym)
  648.                         `(stw r3 (r29 ,(* counter 4)))                        
  649.                         `(lwz r3 (r30 ,(* *arg-count* 4)))
  650.                         `(stw r3 (r29 ,(* (+ counter 1) 4)))
  651.                         `(li r3 0)
  652.                         `(stw r3 (r29 ,(* (+ counter 2) 4)))                        
  653.                         `(addi r3 r29 ,(* *current-call-index* 4))
  654.                         `($CALL #'cl::$push-special-bindings)
  655.                     ]))
  656.  
  657.             (incf *arg-count*))))
  658.  
  659. ;;
  660. ;;    compile-lambda-key-args
  661. ;;    Generates code to initialize key argumensts.
  662. ;;
  663. (defun compile-lambda-key-args ()
  664.     (dolist (n (key-arguments *lambda-list*))
  665.         (let* ((loop-label (gensym))
  666.                (exit-label (gensym))
  667.                (not-found-label (gensym))
  668.                lex-var 
  669.                default-init 
  670.                key-symbol)
  671.                         
  672.             (if (consp n)
  673.                 (setq lex-var (car n))
  674.                 (setq lex-var n))
  675.                             
  676.             (if (and (consp n) (cdr n))
  677.                 (setq default-init (cadr n))
  678.                 (setq default-init nil))                        
  679.                     
  680.             (setq key-symbol 
  681.                 (intern (symbol-name lex-var) (find-package :keyword)))
  682.                         
  683.             [
  684.                 `(mr r26 r27)        ; r26 = current argument location
  685.                 `($LOAD-OBJ r3 ',key-symbol)
  686.                 loop-label
  687.                 `(lwzu r0 (r26 4))            ; is there an argument?
  688.                 `(cmpwi r0 0)
  689.                 `(beq ,not-found-label)
  690.                 `(cmpw r3 r0)
  691.                 `(bne ,loop-label)
  692.                 `(lwzu r3 (r26 4))            ; make sure there is another argument
  693.                 `($CALL #'cl::%checkObj)
  694.                 `(stw r3 (r30 ,(* *arg-count* 4)))
  695.                 `(b ,exit-label)
  696.                 not-found-label    
  697.             ]
  698.             (compile-form default-init)
  699.             [
  700.                 `(stw r28 (r30 ,(* *arg-count* 4)))
  701.                 exit-label
  702.             ]
  703.  
  704.         (if (or (special-variable-p n) (member n *lambda-special-decs*))
  705.                 (let ((counter *current-call-index*))  
  706.                     (parameter-ceiling (+ counter 3))
  707.                     (push n *lambda-special-vars*)
  708.                     [
  709.                         `($LOAD-OBJ r3 ',n)
  710.                         `(stw r3 (r29 ,(* counter 4)))                        
  711.                         `(lwz r3 (r30 ,(* *arg-count* 4)))
  712.                         `(stw r3 (r29 ,(* (+ counter 1) 4)))
  713.                         `(li r3 0)
  714.                         `(stw r3 (r29 ,(* (+ counter 2) 4)))                        
  715.                         `(addi r3 r29 ,(* *current-call-index* 4))
  716.                         `($CALL #'cl::$push-special-bindings)
  717.                     ]))
  718.  
  719.             (incf *arg-count*))))
  720.  
  721. (defun compile-form (form)
  722.     (setq *last-call-was-values* nil)
  723.     (setq *last-call-was-tail-recursion* nil)
  724.     (cond 
  725.         ((null form) (compile-nil))
  726.         ((symbolp form) (compile-symbol form))
  727.         ((not (consp form))    (compile-literal-form form))
  728.         (t (compile-list-form form))))
  729.  
  730.  
  731. (defun compile-list-form (form)
  732.     (let ((firstobj (car form)))
  733.         (cond 
  734.             ((consp firstobj) (compile-explicit-lambda form))
  735.             ((not (symbolp firstobj))
  736.                 (error "Can't compile form--does not begin with a symbol"))
  737.             ((macro-function firstobj) (compile-form (macroexpand form)))
  738.             ((special-form-p firstobj) (compile-special-form form))
  739.             ((eq firstobj 'common-lisp::values) (compile-values-form form))
  740.             (t (compile-function-call-form form)))))
  741.  
  742.  
  743. (defun compile-special-form (form)
  744.     (case (car form)
  745.         (quote                     (compile-quote-form form)) 
  746.         (if                     (compile-if-form form))
  747.         (tagbody                 (compile-tagbody-form form))
  748.         (go                     (compile-go-tag form))
  749.         (setq                     (compile-setq-form form))
  750.         (block                     (compile-block-form form))
  751.         (return-from             (compile-return-from-form form))
  752.         (progn                     (compile-progn-form form))
  753.         (let                     (compile-let-form form))
  754.         (let*                     (compile-let*-form form))
  755.         (flet                     (compile-flet-form form))
  756.         (labels                 (compile-labels-form form))
  757.         (function                (compile-function-special-form form))
  758.         (catch                    (compile-catch-form form))
  759.         (throw                    (compile-throw-form form))
  760.         (unwind-protect         (compile-unwind-protect-form form))
  761.         (multiple-value-call     (compile-multiple-value-call-form form))
  762.         (eval-when                 (compile-eval-when-form form))
  763.         (multiple-value-prog1     (compile-multiple-value-prog1-form form))
  764.         (the                    (compile-the-form form))
  765.         (declare                nil)
  766.         (otherwise                 (error "Special form not supported: ~A~%" (car form)))))
  767.  
  768.  
  769. (defun compile-explicit-lambda (form)
  770.     (if (not (eq 'lambda (caar form)))
  771.         (error "The first element of the expression: ~A is a list but it
  772.                 isn't a lambda expression~%" (car form)))
  773.     (compile-form `(funcall (function ,(car form)) ,@(cdr form))))
  774.  
  775. (defun compile-symbol (sym)
  776.     (let ((temp (find-lex sym)))        ; check for lexical variable
  777.         (if temp
  778.             (if (integerp (cdr temp))
  779.                 [
  780.                     `(lwz r28 (r30 ,(* (cdr temp) 4)))
  781.                 ]
  782.                 ;; else
  783.                 [
  784.                     `(lwz r28 (r30 ,(* (cadr temp) 4)))
  785.                     `($CDR r28 r28)
  786.                 ])
  787.         ;; else see if it is in the inherited environment
  788.             (if (find-in-environment sym)
  789.                 (let ((counter *current-call-index*))
  790.                     (parameter-ceiling (+ counter 3)) 
  791.                     [
  792.                         `(stw r31 (r29 ,(* counter 4)))  
  793.                         `($LOAD-OBJ r3 ',sym)
  794.                         `(stw r3 (r29 ,(* (+ counter 1) 4)))  
  795.                         `(li r3 0)
  796.                         `(stw r3 (r29 ,(* (+ counter 2) 4)))
  797.                         `(addi r3 r29 ,(* *current-call-index* 4))
  798.                         `($CALL #'cl::%environment-get-value)
  799.                         `(mr r28 r3)
  800.                     ])
  801.             ;; else assume special variable
  802.                 (compile-function-call-form `(symbol-value ',sym))))))
  803.                 
  804.  
  805. (defun compile-if-form (form)
  806.     (let ((else-label (gensym)) 
  807.           (end-label (gensym))
  808.           (test-form (cadr form))
  809.           (then-form (caddr form))
  810.           (else-form (cdddr form)))
  811.  
  812.         (compile-form test-form)
  813.         [
  814.             `($LOAD-OBJ r3 'nil)
  815.             `(cmpw r3 r28)
  816.             `(beq ,else-label)
  817.         ]
  818.         (compile-form then-form)
  819.         (if (consp else-form)
  820.             [
  821.                 `(b ,end-label)
  822.             ])
  823.         [
  824.             else-label
  825.         ]
  826.         (if (consp else-form)
  827.             (compile-form (car else-form)))
  828.         [
  829.             end-label
  830.         ]))
  831.  
  832.  
  833. (defun compile-tagbody-form (form)
  834.     (let ((tags nil))
  835.         ;; go through list once collecting tags
  836.         (dolist (n (cdr form))
  837.             (if (or (integerp n) (symbolp n))
  838.                 (push (cons n (gensym)) tags)))
  839.         
  840.         (push-cleanup (cons 'tagbody tags))
  841.  
  842.         (dolist (n (cdr form))
  843.             (if (or (integerp n) (symbolp n))
  844.                 (push (cdr (assoc n tags)) *asm*)
  845.                 ;; else it is a form to be evaluated
  846.                 (compile-form n)))
  847.  
  848.         (pop-cleanup)))
  849.  
  850. (defun compile-go-tag (form)
  851.     (let ((tag (cadr form)))
  852.         (if (not (or (integerp tag) (symbolp tag)))
  853.             (error "Invalid go tag encountered"))
  854.         (if (not (find-go-tag tag))            ;; if the tag is not already defined 
  855.             (error "Tag not defined in this scope"))
  856.  
  857.         ;; peel off cleanup stack
  858.         (let ((dest (find-go-tag-tagbody tag)))
  859.             (dolist (f *cleanup-forms-stack*)
  860.                 (if (eq f dest) (return))        ;; returns from the dolist block
  861.                 (case (car f)
  862.                     (unwind-protect  
  863.                         ;; include cleanup code
  864.                         (let ((cleanup-code (cdr f)))
  865.                             (dolist (n cleanup-code)
  866.                                 (push n *asm*))))
  867.                     (catch
  868.                         ;; remove dynamic catch tag
  869.                         [
  870.                             `($CALL #'cl::%popCatcher)    ;; restore result
  871.                         ]))))
  872.                     
  873.         [
  874.             `(b ,(cdr (find-go-tag tag)))
  875.         ])) 
  876.  
  877. (defun compile-setq-form (form)
  878.     (do ((f (cdr form) (cddr f)) var val temp)
  879.         ((endp f))
  880.         (setq var (car f))
  881.         (setq val (cadr f))
  882.         (setf temp (find-lex var))    ; check for lexical variable
  883.         (if temp
  884.             (progn
  885.                 (compile-form val)
  886.                 (if (integerp (cdr temp))
  887.                     [
  888.                         `(stw r28 (r30 ,(* (cdr temp) 4)))
  889.                     ]
  890.                 ;; else
  891.                     [
  892.                         `(lwz r3 (r30 ,(* (cadr temp) 4)))
  893.                         `($SETCDR r3 r28)
  894.                     ]))
  895.         ;; else look in the inherited environment
  896.             (if (find-in-environment var)
  897.                 (let ((counter *current-call-index*))
  898.                     (parameter-ceiling (+ counter 4))
  899.                     (compile-form val)
  900.                     [
  901.                         `(stw r31 (r29 ,(* (+ counter 0) 4)))                        
  902.                         `($LOAD-OBJ r3 ',var)
  903.                         `(stw r3  (r29 ,(* (+ counter 1) 4)))
  904.                         `(stw r28 (r29 ,(* (+ counter 2) 4)))
  905.                         `(li r3 0)
  906.                         `(stw r3  (r29 ,(* (+ counter 3) 4)))                        
  907.                         `(addi r3 r29 ,(* *current-call-index* 4))
  908.                         `($CALL #'cl::%environment-set-value)
  909.                         `(mr r28 r3)
  910.                     ])
  911.             ;; else call set function
  912.                 (compile-form `(set ',var ,val))))))
  913.  
  914. (defun compile-quote-form (form)
  915.     (compile-literal-form (cadr form)))
  916.  
  917. (defun compile-block-form (form)
  918.     (let ((block-name (cadr form)) 
  919.           (block-forms (cddr form)) 
  920.           (exit-label (gensym)))
  921.         (push-cleanup (list 'block block-name exit-label))
  922.  
  923.         ;; in case an embedded lambda has a (return-from block-name) in it    
  924.         (if (referenced-by-embedded-lambdas block-name)
  925.             (progn (compile-catch-form
  926.                 `(catch ',block-name (progn ,@block-forms)))
  927.                 (warn "had to compile a catch form for a block header: ~A" block-name))
  928.             (dolist (f block-forms)
  929.                 (compile-form f)))
  930.  
  931.         [
  932.             exit-label
  933.         ]
  934.         (pop-cleanup)))
  935.  
  936. (defun compile-return-from-form (form)
  937.     (let ((block-name (cadr form))
  938.           (retval nil)
  939.           temp)
  940.         (if (consp (cddr form))
  941.             (setq retval (caddr form)))
  942.         (if (null block-name)
  943.             (setq temp (find-any-block))
  944.             ;; else
  945.             (setq temp (find-block block-name)))
  946.  
  947.         (if temp
  948.             (progn
  949.                 (compile-form retval)
  950.                 ;; if we are returning multiple values from a block
  951.                 ;; just allow them to be returned from entire lambda
  952.                 ;; since we can't be sure whether they should propogate
  953.                 ;; to the end
  954.                 (if (and (consp retval) (eq (car retval) 'values))
  955.                     (setq *returned-multiple-values* t))) 
  956.             (let ((throw-tag `',block-name) 
  957.                     (throw-form retval)
  958.                     (counter *current-call-index*)) 
  959.  
  960.                 (parameter-ceiling (+ counter 2))
  961.  
  962.                 ;; evaluate the tag
  963.                 (compile-form throw-tag)
  964.                 [
  965.                     `(stw r28 (r29 ,(* counter 4)))
  966.                 ]
  967.  
  968.                 ;; evaluate the form
  969.                 (let ((*current-call-index* (+ counter 3)))
  970.                     (compile-form throw-form))
  971.  
  972.                 ;; peel off cleanup stack
  973.                 (let ((dest temp))
  974.                     (dolist (f *cleanup-forms-stack*)
  975.                         (if (eq f dest) (return))        ;; returns from the dolist block
  976.                         (case (car f)
  977.                             (unwind-protect  
  978.                                 ;; include cleanup code
  979.                                 (let ((cleanup-code (cdr f)))
  980.                                     (dolist (n cleanup-code)
  981.                                         (push n *asm*))))
  982.                             (catch
  983.                                 ;; remove dynamic catch tag
  984.                                 [
  985.                                     `($CALL #'cl::%popCatcher)    ;; restore result
  986.                                 ]))))
  987.  
  988.                 [
  989.                     `(mr r4 r28)
  990.                     `(lwz r3 (r29 ,(* counter 4)))        
  991.                     `($CALL #'cl::%throwException)    ;; call throw handler
  992.                 ]
  993.                 (warn "Block label not found: ~A" block-name)
  994.                 (return)))
  995.  
  996.         ;; peel off cleanup stack
  997.         (let ((dest temp))
  998.             (dolist (f *cleanup-forms-stack*)
  999.                 (if (eq f dest) (return))        ;; returns from the dolist block
  1000.                 (case (car f)
  1001.                     (unwind-protect  
  1002.                         ;; include cleanup code
  1003.                         (let ((cleanup-code (cdr f)))
  1004.                             (dolist (n cleanup-code)
  1005.                                 (push n *asm*))))
  1006.                     (catch
  1007.                         ;; remove dynamic catch tag
  1008.                         [
  1009.                             `($CALL #'cl::%popCatcher)    ;; restore result
  1010.                         ]))))
  1011.  
  1012.         [    
  1013.             `(b ,(caddr temp))
  1014.         ]))    
  1015.  
  1016. (defun compile-progn-form (form)
  1017.     (let ((progn-forms (cdr form))) 
  1018.         (dolist (f progn-forms)
  1019.             (compile-form f))))
  1020.  
  1021. (defun compile-multiple-value-prog1-form (form)
  1022.     (let ((progn-forms (cdr form))
  1023.           (temp-var1 *lex-counter*)
  1024.           (temp-var2 (+ *lex-counter* 1)))
  1025.  
  1026.         ;; if no forms, nothing to do
  1027.         (if (null progn-forms) 
  1028.             (return))
  1029.  
  1030.         ;; if only a single form, just handle as a normal progn
  1031.         (if (null (cdr progn-forms))
  1032.             (progn
  1033.                 (compile-form (car progn-forms))
  1034.                 (return)))
  1035.  
  1036.         ;; make room for temp-vars on stack
  1037.         (incf *lex-counter* 2)
  1038.         (compile-form (car progn-forms))
  1039.  
  1040.         ;; store the result form and the multiple-value contents on stack
  1041.         [
  1042.             `(stw r3 (r30 ,(* temp-var1 4)))        ; save result on stack
  1043.             `($LOAD-LONG r3 cl::%multiple-values-address)
  1044.             `(lwz r3 (r3))
  1045.             `(stw r3 (r30 ,(* temp-var2 4)))        ; save result on stack
  1046.         ]
  1047.  
  1048.         ;; compile the remaining forms
  1049.         (setq progn-forms (cdr progn-forms))         
  1050.         (dolist (f progn-forms)
  1051.             (compile-form f))
  1052.  
  1053.         ;; restore the first return value and any multiple values
  1054.         [
  1055.             `(lwz r28 (r30 ,(* temp-var1 4)))        ;get result in R28
  1056.             `($LOAD-LONG r3 cl::%multiple-values-address)
  1057.             `(lwz r0 (r30 ,(* temp-var2 4)))
  1058.             `(stw r0 (r3))
  1059.         ]
  1060.  
  1061.         (setq *last-call-was-values* t)))
  1062.             
  1063. (defun compile-let-form (form)
  1064.     (let* ((local-vars (cadr form)) 
  1065.            (let-forms (cddr form)) 
  1066.            (new-vars nil)
  1067.            (special-vars nil)
  1068.            (declarations nil)
  1069.            (special-decs nil)
  1070.            (counter *current-call-index*)
  1071.            sym)
  1072.  
  1073.         ;; look for declarations
  1074.         (do ((f let-forms (cdr f)))
  1075.             ((null f) (setq let-forms f))
  1076.             (if (and (consp (car f)) (eq (caar f) 'declare))
  1077.                 (push (car f) declarations)
  1078.                 (progn (setq let-forms f) (return))))
  1079.  
  1080.         ;; search declarations for special declarations
  1081.         (dolist (declaration declarations)
  1082.             (dolist (dec-form (cdr declaration))
  1083.                 (if (and (consp dec-form) (eq (car dec-form) 'special))
  1084.                     (setq special-decs (append (cdr dec-form) special-decs)))))
  1085.                     
  1086.         ;; go through variable list evaluating values and assigning to temporary
  1087.         ;; space on the stack
  1088.         (dolist (f local-vars)
  1089.             (unless (or (consp f) (symbolp f)) 
  1090.                 (error "Invalid 'let' variable"))
  1091.             (if (or (symbolp f) (not (consp (cdr f))))
  1092.                 [
  1093.                     `($LOAD-OBJ r3 'nil) 
  1094.                     `(stw r3 (r30 ,(* *lex-counter* 4)))
  1095.                 ]
  1096.                 ;; else
  1097.                 (let ((*current-call-index* counter))
  1098.                     (compile-form (cadr f))
  1099.                     [
  1100.                         `(stw r28 (r30 ,(* *lex-counter* 4)))
  1101.                     ]))
  1102.  
  1103.             ;; add the symbol to the list of new symbols
  1104.             (if (consp f) 
  1105.                 (setq sym (car f)) 
  1106.                 (setq sym f)) 
  1107.                 
  1108.             (if (or (special-variable-p sym) (member sym special-decs))
  1109.                 (progn 
  1110.                     (push sym special-vars)
  1111.                     [
  1112.                         `($LOAD-OBJ r3 ',sym)
  1113.                         `(stw r3 (r29 ,(* counter 4)))                        
  1114.                         `(lwz r3 (r30 ,(* *lex-counter* 4)))
  1115.                         `(stw r3 (r29 ,(* (1+ counter) 4)))
  1116.                     ]
  1117.                     (incf counter 2))
  1118.                 ;; else
  1119.                 (push (cons sym *lex-counter*) new-vars))
  1120.  
  1121.             (incf *lex-counter*))
  1122.  
  1123.         ;; add the new variables to the lexical environment
  1124.         (add-lexical-variables new-vars)
  1125.         (create-runtime-bindings)
  1126.         
  1127.         ;; if any special variables are present, add those bindings now
  1128.         (if special-vars
  1129.             (progn 
  1130.                 [
  1131.                     `(li r3 0)
  1132.                     `(stw r3 (r29 ,(* counter 4)))                        
  1133.                     `(addi r3 r29 ,(* *current-call-index* 4))
  1134.                     `($CALL #'cl::$push-special-bindings)
  1135.                 ]
  1136.                 (incf counter)
  1137.                 (parameter-ceiling counter)
  1138.                 (let ((*current-call-index* counter))
  1139.                     (compile-unwind-protect-form 
  1140.                         `(unwind-protect 
  1141.                             (progn ,@let-forms)
  1142.                             ($pop-special-bindings ',special-vars)))))
  1143.  
  1144.             ;; else execute the forms directly
  1145.             (dolist (f let-forms)
  1146.                 (compile-form f)))
  1147.         
  1148.         ;; restore old lexical environment
  1149.         (pop-cleanup)))
  1150.  
  1151. (defun compile-let*-form (form)
  1152.     (let* ((local-vars (cadr form)) 
  1153.            (let-forms (cddr form))
  1154.            (special-vars nil)
  1155.            (declarations nil)
  1156.            (special-decs nil)
  1157.            sym
  1158.            (counter *current-call-index*)
  1159.            (lex-var-count 0))
  1160.  
  1161.         ;; look for declarations
  1162.         (do ((f let-forms (cdr f)))
  1163.             ((null f) (setq let-forms f))
  1164.             (if (and (consp (car f)) (eq (caar f) 'declare))
  1165.                 (push (car f) declarations)
  1166.                 (progn (setq let-forms f) (return))))
  1167.  
  1168.         ;; search declarations for special declarations
  1169.         (dolist (declaration declarations)
  1170.             (dolist (dec-form (cdr declaration))
  1171.                 (if (and (consp dec-form) (eq (car dec-form) 'special))
  1172.                     (setq special-decs (append (cdr dec-form) special-decs)))))
  1173.  
  1174.         ;; go through variable list evaluating values and assigning to temporary
  1175.         ;; space on the stack
  1176.         (dolist (f local-vars)
  1177.             (unless (or (consp f) (symbolp f)) 
  1178.                 (error "Invalid 'let*' variable: ~A~%" f))
  1179.             (if (or (symbolp f) (not (consp (cdr f))))
  1180.                 [
  1181.                     `($LOAD-OBJ r3 'nil) 
  1182.                     `(stw r3 (r30 ,(* *lex-counter* 4)))
  1183.                 ]
  1184.                 ;; else
  1185.                 (progn
  1186.                     (compile-form (cadr f))
  1187.                     [
  1188.                         `(stw r28 (r30 ,(* *lex-counter* 4)))
  1189.                     ]))
  1190.  
  1191.             ;; add the symbol to the list of new symbols
  1192.             (if (consp f) 
  1193.                 (setq sym (car f)) 
  1194.                 (setq sym f)) 
  1195.     
  1196.             (if (or (special-variable-p sym) (member sym special-decs))
  1197.                 (progn 
  1198.                     (push sym special-vars)
  1199.                     (parameter-ceiling (+ counter 3))
  1200.                     [
  1201.                         `($LOAD-OBJ r3 ',sym)
  1202.                         `(stw r3 (r29 ,(* counter 4)))                        
  1203.                         `(lwz r3 (r30 ,(* *lex-counter* 4)))
  1204.                         `(stw r3 (r29 ,(* (+ counter 1) 4)))
  1205.                         `(li r3 0)
  1206.                         `(stw r3 (r29 ,(* (+ counter 2) 4)))                        
  1207.                         `(addi r3 r29 ,(* *current-call-index* 4))
  1208.                         `($CALL #'cl::$push-special-bindings)
  1209.                     ])
  1210.                 ;; else
  1211.                 (progn
  1212.                     (add-lexical-variables (list (cons sym *lex-counter*)))
  1213.                     (incf lex-var-count)))
  1214.  
  1215.             (incf *lex-counter*))
  1216.  
  1217.         (create-runtime-bindings)    
  1218.         
  1219.         ;; if any special variables are present, add those bindings now
  1220.         (if special-vars
  1221.             (compile-unwind-protect-form 
  1222.                 `(unwind-protect 
  1223.                     (progn ,@let-forms)
  1224.                     ($pop-special-bindings ',special-vars)))
  1225.  
  1226.             ;; else execute the forms directly
  1227.             (dolist (f let-forms)
  1228.                 (compile-form f)))
  1229.         
  1230.         ;; restore old lexical environment
  1231.         (dotimes (i lex-var-count)
  1232.             (pop-cleanup))))
  1233.  
  1234. (defun compile-flet-form (form)
  1235.     (let* ((local-funs (cadr form)) 
  1236.            (flet-forms (cddr form)) 
  1237.            (new-funs nil)
  1238.            (declarations nil))
  1239.  
  1240.         ;; look for declarations
  1241.         (do ((f flet-forms (cdr f)))
  1242.             ((null f) (setq flet-forms f))
  1243.             (if (and (consp (car f)) (eq (caar f) 'declare))
  1244.                 (push (car f) declarations)
  1245.                 (progn (setq flet-forms f) (return))))
  1246.  
  1247.         ;; search declarations for special declarations
  1248. ;;
  1249. ;;        ;; do we need to deal with special declarations here?  RGC
  1250. ;;        (dolist (declaration declarations)
  1251. ;;            (dolist (dec-form (cdr declaration))
  1252. ;;                (if (and (consp dec-form) (eq (car dec-form) 'special))
  1253. ;;                    (setq special-decs (append (cdr dec-form) special-decs)))))
  1254. ;;                    
  1255.         ;; go through function list evaluating values and assigning to temporary
  1256.         ;; space on the stack
  1257.         (dolist (f local-funs)
  1258.             (unless (and (consp f) (consp (cdr f)))
  1259.                 (error "Invalid 'flet' function expression"))
  1260.             (let* ((func-name (car f))
  1261.                    (func-args (cadr f))
  1262.                    (func-forms (cddr f)))
  1263.                 (compile-function-special-form 
  1264.                     `(function (lambda ,func-args (block ,func-name ,@func-forms))))
  1265.                 [
  1266.                     `(stw r28 (r30 ,(* *lex-counter* 4)))
  1267.                 ]
  1268.     
  1269.                 ;; add the function name to the list of new functions
  1270.                 (push (cons func-name *lex-counter*) new-funs)                
  1271.                 (incf *lex-counter*)))
  1272.  
  1273.         ;; add the new functions to the lexical environment
  1274.         (add-lexical-functions new-funs)
  1275.         (create-runtime-bindings)
  1276.         
  1277.         ;; execute the forms directly
  1278.         (dolist (f flet-forms)
  1279.             (compile-form f))
  1280.         
  1281.         ;; restore old lexical environment
  1282.         (pop-cleanup)))
  1283.  
  1284. (defun compile-labels-form (form)
  1285.     (let* ((local-funs (cadr form)) 
  1286.            (flet-forms (cddr form)) 
  1287.            (new-funs nil)
  1288.            (declarations nil)
  1289.            first-func-position)
  1290.  
  1291.         ;; look for declarations
  1292.         (do ((f flet-forms (cdr f)))
  1293.             ((null f) (setq flet-forms f))
  1294.             (if (and (consp (car f)) (eq (caar f) 'declare))
  1295.                 (push (car f) declarations)
  1296.                 (progn (setq flet-forms f) (return))))
  1297.  
  1298.         ;; search declarations for special declarations
  1299. ;;
  1300. ;;        ;; do we need to deal with special declarations here?  RGC
  1301. ;;        (dolist (declaration declarations)
  1302. ;;            (dolist (dec-form (cdr declaration))
  1303. ;;                (if (and (consp dec-form) (eq (car dec-form) 'special))
  1304. ;;                    (setq special-decs (append (cdr dec-form) special-decs)))))
  1305. ;;
  1306.         (setq first-func-position *lex-counter*)                    
  1307.         (dolist (f local-funs)
  1308.             (unless (and (consp f) (consp (cdr f)))
  1309.                 (error "Invalid 'labels' function expression"))
  1310.             (let* ((func-name (car f)))
  1311.                 (push (cons func-name *lex-counter*) new-funs)
  1312.                 (add-to-environment func-name)        ;; debug        
  1313.                 (incf *lex-counter*)))
  1314.  
  1315.         ;; add the new functions to the lexical environment
  1316.         (add-lexical-functions (reverse new-funs))
  1317.         
  1318.         ;; go through function list evaluating values and assigning to temporary
  1319.         ;; space on the stack
  1320.         (dolist (f local-funs)
  1321.             (let* ((func-name (car f))
  1322.                    (func-args (cadr f))
  1323.                    (func-forms (cddr f))
  1324.                    (pos (cdr (find func-name new-funs :key #'car))))
  1325.                 (if (consp pos)
  1326.                     (setq pos (car pos)))
  1327.                 (compile-function-special-form 
  1328.                     `(function (lambda ,func-args (block ,func-name ,@func-forms))))
  1329.  
  1330.                 (let ((temp (find-lex-function func-name)))    ; check for lexical function
  1331.                     (if temp
  1332.                         (if (integerp (cdr temp))
  1333.                             [
  1334.     ;;                            `(stw r28 (r30 ,(* pos 4)))
  1335.                                 `(stw r28 (r30 ,(* (cdr temp) 4)))
  1336.                             ]
  1337.                             ;; else
  1338.                             [
  1339.                                 `(lwz r26 (r30 ,(* (cadr temp) 4)))
  1340.                                 `(stw r28 (r26 4))    ;; store in CDR field of binding
  1341.                             ])))))
  1342.  
  1343.         (create-runtime-bindings)
  1344.  
  1345.         ;; execute the forms directly
  1346.         (dolist (f flet-forms)
  1347.             (compile-form f))
  1348.  
  1349.         
  1350.         ;; restore old lexical environment
  1351.         (pop-cleanup)))
  1352.  
  1353. (defun compile-function-special-form (form)
  1354.     (let ((func-form (cadr form)))
  1355.         
  1356.         ;; I don't think this will occur, but just in case, we can't
  1357.         ;; keep a reference to an anonymous function object.
  1358.         (if (functionp func-form)
  1359.             (error "Can't compile expression with anonymous function: ~A~%" form))
  1360.  
  1361.         ;; if a compiled lambda expression
  1362.         (if (and (consp func-form) (eq (car func-form) 'lambda))
  1363.             (let ((name nil)
  1364.                   (first-form (third func-form))
  1365.                   (counter *current-call-index*))
  1366.                 (if (and (consp first-form) (eq (first first-form) 'block))
  1367.                     (setq name (second (third func-form))))
  1368.  
  1369.                 ;; create a new compiled function
  1370.                 (parameter-ceiling (+ counter 2))
  1371.                 (setq func-form (compile-lambda func-form name))     
  1372.                 [
  1373.                     `($LOAD-OBJ r3 ',func-form)
  1374.                     `(stw r3 (r29 ,(* counter 4)))
  1375.                     `(li r3 0)
  1376.                     `(stw r3 (r29 ,(* (+ counter 1) 4)))
  1377.                     `(addi r3 r29 ,(* *current-call-index* 4))
  1378.                     `($CALL #'cl::%copy-compiled-function)
  1379.                     `(mr r28 r3)
  1380.                 ]
  1381.                 (create-runtime-bindings)
  1382.                 (export-environment)
  1383.                 (return)))
  1384.                 
  1385.         (unless (symbolp func-form)
  1386.             (error "function special form: ~%Expected a symbol: ~A~%" func-form))
  1387.  
  1388.         (let ((temp (find-lex-function func-form)))    ; check for lexical function
  1389.             (if temp
  1390.                 (if (integerp (cdr temp))
  1391.                     [
  1392.                         `(lwz r28 (r30 ,(* (cdr temp) 4)))
  1393.                     ]
  1394.                     ;; else
  1395.                     [
  1396.                         `(lwz r28 (r30 ,(* (cadr temp) 4)))
  1397.                         `($CDR r28)
  1398.                     ])
  1399.                 ;; else see if it is in the inherited environment
  1400.                 (if (find-in-environment func-form)
  1401.                     (let ((counter *current-call-index*))
  1402.                         (parameter-ceiling (+ counter 3))
  1403.                         [
  1404.                             `(stw r31 (r29 ,(* counter 4)))
  1405.                             `($LOAD-OBJ r3 ',func-form)
  1406.                             `(stw r3 (r29 ,(* (+ counter 1) 4)))
  1407.                             `(li r3 0)
  1408.                             `(stw r3 (r29 ,(* (+ counter 2) 4)))
  1409.                             `(addi r3 r29 ,(* *current-call-index* 4))
  1410.                             `($CALL #'cl::%environment-get-function)
  1411.                             `(mr r28 r3)
  1412.                         ])
  1413.                         
  1414.                 ;; else assume global function
  1415.                     (compile-function-call-form `(symbol-function ',func-form)))))))
  1416.  
  1417. (defun compile-catch-form (form)
  1418.     (let ((catch-tag (cadr form)) 
  1419.           (catch-forms (cddr form)) 
  1420.           (exit-label (gensym))
  1421.           (jmpbuf-addr *lex-counter*))
  1422.  
  1423.         (push-cleanup (list 'CATCH catch-tag))
  1424.         
  1425.         ;; evaluate the tag
  1426.         (compile-form catch-tag)
  1427.         
  1428.         ;; make room for jmp-buf on stack
  1429.         (incf *lex-counter* *jmp_buf-size*)
  1430.         [
  1431.         ;; pushCatcher(tag, jmp_buf)
  1432.             `(mr r3 r28)                        ; tag
  1433.             `(addi r4 r30 ,(* jmpbuf-addr 4))    ; jmp_buf 
  1434.             `($CALL #'cl::%pushCatcher)
  1435.  
  1436.         ;; setjmp(jmp_buf)
  1437.             `(addi r3 r30 ,(* jmpbuf-addr 4))
  1438.             `($CALL #'common-lisp::%setjmp)
  1439.         
  1440.         ;; if result != 0, we caught an exception
  1441.             `(mr r28 r3)
  1442.             `(cmpwi r3 0)
  1443.             `(bne ,exit-label) 
  1444.             `($LOAD-OBJ r28 'nil)
  1445.         ]
  1446.         
  1447.         (dolist (f catch-forms)
  1448.             (compile-form f))
  1449.  
  1450.         [
  1451.             exit-label
  1452.         ]
  1453.         
  1454.         (pop-cleanup)
  1455.         
  1456.         ;; popCatcher()
  1457.         [
  1458.             `($CALL #'cl::%popCatcher)
  1459.         ]))
  1460.  
  1461. (defun compile-throw-form (form)
  1462.     (let ((throw-tag (cadr form)) 
  1463.           (throw-form (caddr form))
  1464.           (counter *current-call-index*)) 
  1465.  
  1466.         (parameter-ceiling (+ counter 2))
  1467.  
  1468.         ;; evaluate the tag
  1469.         (compile-form throw-tag)
  1470.         [
  1471.             `(stw r28 (r29 ,(* counter 4)))
  1472.         ]
  1473.  
  1474.         ;; evaluate the form
  1475.         (let ((*current-call-index* (+ counter 3)))
  1476.             (compile-form throw-form))
  1477.         [
  1478.             `(mr r4 r28)
  1479.             `(lwz r3 (r29 ,(* counter 4)))        
  1480.             `($CALL #'cl::%throwException)    ;; call throw handler
  1481.         ]))
  1482.  
  1483. (defun compile-unwind-protect-form (form)
  1484.     (let ((protected-form (cadr form))
  1485.           (cleanup-forms (cddr form)) 
  1486.           (label1 (gensym))
  1487.           (label2 (gensym))
  1488.           (temp-var1 *lex-counter*)
  1489.           (temp-var2 (+ *lex-counter* 1))
  1490.           (temp-var3 (+ *lex-counter* 2))
  1491.           (jmpbuf-addr (+ *lex-counter* 3)))
  1492.         
  1493.         ;; make room for jmp-buf and temp-var on stack
  1494.         (incf *lex-counter* (+ *jmp_buf-size* 3))
  1495.         [
  1496.             ;; pushCatcher(tag, jmp_buf)
  1497.             `(li r3 0)                            ; 1st arg = tag (special tag 0)
  1498.             `(addi r4 r30 ,(* jmpbuf-addr 4))    ; jmp_buf 
  1499.             `($CALL #'cl::%pushCatcher)
  1500.  
  1501.             ;; setjmp(jmp_buf)
  1502.             `(addi r3 r30 ,(* jmpbuf-addr 4))
  1503.             `($CALL #'common-lisp::%setjmp)
  1504.         
  1505.             ;; if result != 0, we caught an exception
  1506.             `(mr r28 r3)
  1507.             `(stw r3 (r30 ,(* temp-var1 4)))        ; save result on stack
  1508.             `(cmpwi r3 0)
  1509.             `(bne ,label1) 
  1510.         ]
  1511.         
  1512.         ;; generate code for cleanup forms
  1513.         (let ((*asm* nil))
  1514.             [
  1515.                 `(stw r28 (r30 ,(* temp-var2 4)))    ; store result
  1516.                 `($LOAD-LONG r3 cl::%multiple-values-address)
  1517.                 `(lwz r3 (r3))                ; get current mv result
  1518.                 `(stw r3 (r30 ,(* temp-var3 4)))
  1519.                 `($CALL #'cl::%popCatcher)
  1520.             ]
  1521.             (dolist (f cleanup-forms)
  1522.                 (compile-form f))
  1523.             [
  1524.                 `(lwz r0 (r30 ,(* temp-var3 4)))
  1525.                 `($LOAD-LONG r3 cl::%multiple-values-address)
  1526.                 `(stw r0 (r3))
  1527.                 `(lwz r28 (r30 ,(* temp-var2 4)))
  1528.             ]
  1529.             (setq *asm* (nreverse *asm*))
  1530.             (push-cleanup (cons 'UNWIND-PROTECT *asm*))) 
  1531.         
  1532.         ;; compile protected form
  1533.         (compile-form protected-form)
  1534.  
  1535.         [
  1536.             label1
  1537.         ]
  1538.         
  1539.         ;; include cleanup code
  1540.         (let ((cleanup-code (cdr (pop-cleanup))))
  1541.             (dolist (n cleanup-code)
  1542.                 (push n *asm*)))
  1543.                 
  1544.         ;; retrieve exception result
  1545.         [
  1546.             `(lwz r3 (r30 ,(* temp-var1 4)))
  1547.             `(cmpwi r3 0)
  1548.             `(beq ,label2)
  1549.  
  1550.             ;; continue thrown exception
  1551.             `($CALL #'cl::%continueException)
  1552.             label2
  1553.         ]))
  1554.  
  1555. ;; for non toplevel eval-when forms
  1556. (defun compile-eval-when-form (form)
  1557.     (if (or (not (consp form)) (< (length form) 2) (not (listp (cadr form))))
  1558.         (error "'eval-when' form missing condition list."))
  1559.  
  1560.     (let* ((conditions (cadr form)))
  1561.         (if (or (member 'common-lisp::eval conditions) 
  1562.                 (member :execute conditions))
  1563.             (compile-progn-form (cons 'common-lisp::progn (cddr form)))
  1564.             (compile-nil))))    
  1565.  
  1566. (defun compile-multiple-value-call-form (form)
  1567.     (let* ((func (cadr form))
  1568.            (forms (cddr form))
  1569.            (numforms (length forms))
  1570.            (counter 0)
  1571.            (temp-var1 *lex-counter*)
  1572.            (dummy (+ *lex-counter* 1))    ; we need an open slot here
  1573.            (call-params (+ *lex-counter* 2))
  1574.            (pcounter *current-call-index*)
  1575.            temp)
  1576.         (parameter-ceiling (+ pcounter 3))
  1577.         (incf *lex-counter* (+ numforms 3))    ; numforms + 2 vars + 0 terminator
  1578.         (compile-form func)
  1579.         [
  1580.             `(stw r28 (r30 ,(* temp-var1 4)))    ; save function address
  1581.         ]
  1582.         (dolist (p forms)                    ; execute each form
  1583.             (compile-form p)
  1584.             [
  1585.                 `($IFELSE 
  1586.                     (
  1587.                         ($LOAD-LONG r3 cl::%multiple-values-address)
  1588.                         (lwz r0 (r3))
  1589.                         (cmpwi r0 0)
  1590.                     )
  1591.                     (
  1592.                         ;; if no multiple values, just list the single value
  1593.                         (stw r28 (r29 ,(* pcounter 4)))
  1594.                         ($LOAD-OBJ r0 'nil)
  1595.                         (stw r0 (r29 ,(* (+ pcounter 1) 4)))
  1596.                         (li r0 0)
  1597.                         (stw r0 (r29 ,(* (+ pcounter 2) 4)))
  1598.                         (addi r3 r29 ,(* *current-call-index* 4))
  1599.                         ($CALL #'cons)
  1600.                         (mr r28 r3)
  1601.                     )
  1602.                     (
  1603.                         ;; otherwise get the list of values
  1604.                         (mr r28 r0)
  1605.                     ))    
  1606.                 `(stw r28 (r30 ,(* (+ call-params counter) 4)))                        
  1607.             ]
  1608.             (incf counter))
  1609.         
  1610.         ;; concatenate all the lists together and store in d3
  1611.         [
  1612.             `(li r0 0)
  1613.             `(stw r0 (r30 ,(* (+ call-params counter) 4)))                        
  1614.             `(addi r3 r30 ,(* call-params 4))
  1615.             `($CALL #'append)
  1616.             `(mr r28 r3)
  1617.         ]
  1618.  
  1619.         ;; now apply the passed function to the resulting value list
  1620.         (setq pcounter *current-call-index*)
  1621.         [
  1622.             `(lwz r0 (r30 ,(* temp-var1 4)))    ; get saved function address
  1623.             `(stw r0 (r29 ,(* pcounter 4)))
  1624.             `(stw r28 (r29 ,(* (+ pcounter 1) 4))) ; argument list
  1625.             `(li r0 0)
  1626.             `(stw r0 (r29 ,(* (+ pcounter 2) 4)))
  1627.             `(addi r3 r29 ,(* *current-call-index* 4))
  1628.             `($CALL #'apply)
  1629.             `(mr r28 r3)
  1630.         ]))
  1631.  
  1632. (defun compile-the-form (form)
  1633.     (let ((type (cadr form))
  1634.           (expr (caddr form)))
  1635.         (compile-form expr)))
  1636.  
  1637. (defun compile-values-form (form)
  1638.     (compile-function-call-form form)
  1639.     (setq *last-call-was-values* t))
  1640.     
  1641. (defun compile-function-call-form (form)
  1642. ;;
  1643. ;;    ;; print warning message if function hasn't been defined yet
  1644. ;;    (if (not (functionp (symbol-function (car form))))
  1645. ;;        (format t "Warning: function ~A missing definition~%" (car form)))
  1646. ;;
  1647.     (if (or (find-lex-function (car form)) (find-in-environment (car form)))
  1648.         (progn
  1649.             (compile-function-call-form `(funcall (function ,(car form)) ,@(cdr form)))
  1650.             (return)))
  1651.  
  1652.     (let* ((numparams (1- (length form)))
  1653.            (stackframe (* 4 (1+ numparams)))
  1654.            (func (car form))
  1655.            (funcparams (cdr form))
  1656.            (counter (1+ *current-call-index*))    ;; save an extra space before params
  1657.            (tail-recursive (if (eq func *function-name*) *asm*))
  1658.            temp)
  1659.  
  1660.         (dolist (p funcparams)                ; get parameters for function call
  1661.             (setf temp (find-lex p))        ; check for lexical variable
  1662.             (if temp
  1663.                 (if (integerp (cdr temp))
  1664.                     [
  1665.                         `(lwz r0 (r30 ,(* (cdr temp) 4)))    ; get lexical var
  1666.                         `(stw r0 (r29 ,(* counter 4)))        ; store it as a parameter
  1667.                     ]
  1668.                     ;; else
  1669.                     [
  1670.                         `(lwz r3 (r30 ,(* (cadr temp) 4)))
  1671.                         `($CDR r3)
  1672.                         `(stw r3 (r29 ,(* counter 4)))
  1673.                     ])
  1674.                 ;; else
  1675.                 (let ((*current-call-index* counter))
  1676.                     (compile-form p)    ; ignore multiple values in params
  1677.                     [
  1678.                         `(stw r28 (r29 ,(* counter 4)))
  1679.                     ]))
  1680.             (incf counter))
  1681.         
  1682.         ;; clear the last position to zero
  1683.         [
  1684.             `(li r3 0)
  1685.             `(stw r3 (r29 ,(* counter 4)))
  1686.             `(addi r3 r29 ,(* (1+ *current-call-index*) 4))    ; pass address of params to function
  1687.         ]
  1688.         (incf counter)
  1689.  
  1690.         (parameter-ceiling counter)
  1691.         
  1692.         ;; if it is a recursive call to this function, we need to handle it specially
  1693.         (if (eq func *function-name*)
  1694.             [
  1695.                 `(bl ,*function-entry-label*)
  1696.             ]
  1697.         ;; else
  1698.             (progn
  1699.                 [
  1700.                     `($CALL #',func)
  1701.                 ]))
  1702.         
  1703.         [
  1704.             `(mr r28 r3)    
  1705.         ]
  1706.  
  1707.         ;; flag tail recursion
  1708.         (setq *last-call-was-tail-recursion* tail-recursive)))
  1709.  
  1710. (defun compile-integer (form)
  1711.     (if (typep form 'bignum)
  1712.         (compile-bignum form)
  1713.         [
  1714.             `(lis r3 ,(cl::%fixnum-upper16 form))
  1715.             `(ori r3 r3 ,(cl::%fixnum-lower16 form))
  1716.             `($CALL #'common-lisp::%integerAtom)
  1717.             `(mr r28 r3)
  1718.         ]))
  1719.  
  1720. (defun compile-bignum (num)
  1721.   (let* ((numcells (cl::%bignum-cells num))
  1722.          (length-flag (if (minusp num) (- numcells) numcells))
  1723.          (temp-label (gensym)))
  1724.         [
  1725.             `(bl ,temp-label)
  1726.             `(dc.l ,length-flag)
  1727.         ]
  1728.         (dotimes (i numcells)
  1729.             [
  1730.                 `(dc.l ,(cl::%bignum-cell num i))    
  1731.             ])
  1732.         [
  1733.             temp-label
  1734.             `(mflr r3)
  1735.             `($CALL #'cl::%bignumAtomFromLongs)
  1736.             `(mr r28 r3)
  1737.         ]))
  1738.  
  1739. (defun string-int-with-pad (string index)
  1740.     (if (>= index (length string))
  1741.         0
  1742.         (char-int (elt string index))))
  1743.     
  1744. (defun compile-string (string)
  1745.     (let* ((numchars (+ 1 (length string)))
  1746.         n
  1747.         temp
  1748.         (num-longs (truncate (+ 3 numchars) 4))
  1749.         (temp-label (gensym)))
  1750.  
  1751.         [
  1752.             `(bl ,temp-label)
  1753.         ]
  1754.  
  1755.         (dotimes (i num-longs)
  1756.             (setq temp (* i 4))
  1757.  
  1758.             ;; gather four characters into a long
  1759.             (setq n
  1760.                 (+
  1761.                     (* (string-int-with-pad string temp) #x1000000)
  1762.                     (* (string-int-with-pad string (+ temp 1)) #x10000)
  1763.                     (* (string-int-with-pad string (+ temp 2)) #x100)
  1764.                     (string-int-with-pad string (+ temp 3))))
  1765.             [
  1766.                 `(dc.l ,n)
  1767.             ])
  1768.  
  1769.         [
  1770.             temp-label
  1771.             `(mflr r3)
  1772.             `($CALL #'cl::%stringAtom)
  1773.             `(mr r28 r3)
  1774.         ]))
  1775.  
  1776. ;; need to add support for bit-vectors
  1777. (defun compile-literal-form (form)
  1778.     (cond
  1779.         ((symbolp form)        [ `($LOAD-OBJ r28 ',form) ])            
  1780.         ((integerp form)     (compile-integer form))
  1781.         ((stringp form)        (compile-string form))
  1782.         ((characterp form)     (compile-character form))
  1783.         ((listp form)         (compile-quoted-list form))
  1784.         ((vectorp form)        (compile-vector form))
  1785.         ((floatp form)        (compile-float form))
  1786.         ((typep form 'ratio)(compile-ratio form))
  1787.         ((typep form 'complex)(compile-complex form))
  1788.         
  1789.         ;; we will have to code a direct reference to the object
  1790.         ;; This won't work if we use 'compile-file'.
  1791.         (t [ `($LOAD-OBJ r28 ',form) ])))
  1792.             
  1793. (defun compile-character (form)
  1794.     [
  1795.         `(li r3 ,(char-int form))
  1796.         `($CALL #'cl::%charAtom)
  1797.         `(mr r28 r3)
  1798.     ])
  1799.     
  1800. ;;
  1801. ;;    compile-quoted-list()
  1802. ;;    We catch and save the last form in case we are dealing with
  1803. ;;    a dotted list or dot pair.
  1804. ;;
  1805. (defun compile-quoted-list (form &aux (last-element (cdr (last form))))
  1806.     (let ((list-length (length form))
  1807.           (counter *current-call-index*))
  1808.         (parameter-ceiling (+ counter list-length 2))
  1809.         (setq form (copy-list form))    ; replaces last cdr with nil
  1810.         (dolist (f form)
  1811.             (let ((*current-call-index* counter))
  1812.                 (compile-literal-form f))
  1813.             [
  1814.                 `(stw r28 (r29 ,(* counter 4)))
  1815.             ]
  1816.             (incf counter))
  1817.  
  1818.         (let ((*current-call-index* counter))
  1819.             (compile-literal-form last-element))
  1820.         [
  1821.             `(stw r28 (r29 ,(* counter 4)))
  1822.             `(li r0 0)
  1823.             `(stw r0 (r29 ,(* (+ counter 1) 4)))
  1824.             `(addi r3 r29 ,(* *current-call-index* 4))
  1825.             `($CALL #'cl::list*)
  1826.             `(mr r28 r3)
  1827.         ]))
  1828.  
  1829. ;;
  1830. ;;    compile-vector()
  1831. ;;
  1832. (defun compile-vector (form)
  1833.     (setq form (concatenate 'list form))
  1834.     (let ((list-length (length form))
  1835.           (counter *current-call-index*))
  1836.         (parameter-ceiling (+ counter list-length 1))
  1837.         (dolist (f form)
  1838.             (let ((*current-call-index* counter))
  1839.                 (compile-literal-form f))
  1840.             [
  1841.                 `(stw r28 (r29 ,(* counter 4)))
  1842.             ]
  1843.             (incf counter))
  1844.  
  1845.         [
  1846.             `(li r0 0)
  1847.             `(stw r0 (r29 ,(* counter 4)))
  1848.             `(addi r3 r29 ,(* *current-call-index* 4))
  1849.             `($CALL #'cl::vector)
  1850.             `(mr r28 r3)
  1851.         ]))
  1852.  
  1853. ;; define these in order to get at the binary representation of a floating
  1854. ;; point number so that we can generate the machine code to build it.
  1855. ;; These functions don't check their type, so we get get the data.
  1856.  
  1857. (defasm %fp-upper-32 (x)
  1858. #{
  1859.     ($FUNC-BEGIN 200)
  1860.     (lwz r3 (r3))
  1861.     (lwz r3 (r3))
  1862.     ($CALL #'cl::%createInteger)
  1863.     ($RETURN r3 200)
  1864. })
  1865.  
  1866. (defasm %fp-lower-32 (x)
  1867. #{
  1868.     ($FUNC-BEGIN 200)
  1869.     (lwz r3 (r3))
  1870.     (lwz r3 (r3 4))
  1871.     ($CALL #'cl::%createInteger)
  1872.     ($RETURN r3 200)
  1873. })
  1874.  
  1875. ;;
  1876. ;;    compile-float()
  1877. ;;
  1878. (defun compile-float (form)
  1879.     (let ((temp-label (gensym)))
  1880.         [
  1881.             `(bl ,temp-label)
  1882.             `(dc.l ,(%fp-upper-32 form))
  1883.             `(dc.l ,(%fp-lower-32 form))
  1884.             temp-label
  1885.             `(mflr r3)
  1886.             `(lfd fp1 (r3))
  1887.             `($CALL #'cl::%floatAtom)
  1888.             `(mr r28 r3)
  1889.         ]))
  1890.  
  1891. ;;
  1892. ;;    compile-ratio()
  1893. ;;
  1894. (defun compile-ratio (form)
  1895.     (let ((counter *current-call-index*))
  1896.         (parameter-ceiling (+ counter 3))
  1897.         (compile-form (numerator form))
  1898.         [
  1899.             `(stw r28 (r29 ,(* (+ counter 0) 4)))    
  1900.         ]
  1901.         (let ((*current-call-index* (+ counter 1)))
  1902.             (compile-form (denominator form)))
  1903.         [
  1904.             `(stw r28 (r29 ,(* (+ counter 1) 4)))
  1905.             `(li r3 0)
  1906.             `(stw r3 (r29 ,(* (+ counter 2) 4)))
  1907.             `(addi r3 r29 ,(* *current-call-index* 4))
  1908.             `($CALL #'cl::/)
  1909.             `(mr r28 r3)    
  1910.         ]))
  1911.     
  1912. ;;
  1913. ;;    compile-complex()
  1914. ;;
  1915. (defun compile-complex (form)
  1916.     (let ((counter *current-call-index*))
  1917.         (parameter-ceiling (+ counter 3))
  1918.         (compile-form (realpart form))
  1919.         [
  1920.             `(stw r28 (r29 ,(* (+ counter 0) 4)))    
  1921.         ]
  1922.         (let ((*current-call-index* (+ counter 1)))
  1923.             (compile-form (imagpart form)))
  1924.         [
  1925.             `(stw r28 (r29 ,(* (+ counter 1) 4)))
  1926.             `(li r3 0)
  1927.             `(stw r3 (r29 ,(* (+ counter 2) 4)))
  1928.             `(addi r3 r29 ,(* *current-call-index* 4))
  1929.             `($CALL #'cl::complex)
  1930.             `(mr r28 r3)    
  1931.         ]))
  1932.  
  1933. (defun check-lambda (lambda)
  1934.     (let ((lambda-list (cadr lambda)))
  1935.         (dolist (n lambda-list)
  1936.             (if (member n *unsupported-lambda-list-keywords*)
  1937.                 (error "Can't compile this lambda list keyword: ~A~%" n)))))
  1938.             
  1939.     
  1940. (defun find-lex (var)
  1941.     (let (found)
  1942.         (dolist (n *cleanup-forms-stack* nil)
  1943.             (if (eq (car n) 'LET)
  1944.                 (progn
  1945.                     (setq found (assoc var (cdr n)))
  1946.                     (if found (return-from find-lex found)))))))
  1947.  
  1948. (defun find-lex-function (var)
  1949.     (let (found)
  1950.         (dolist (n *cleanup-forms-stack* nil)
  1951.             (if (eq (car n) 'FLET)
  1952.                 (progn
  1953.                     (setq found (assoc var (cdr n)))
  1954.                     (if found (return-from find-lex-function found)))))))
  1955.  
  1956. (defun find-go-tag (var)
  1957.     (let (found)
  1958.         (dolist (n *cleanup-forms-stack* nil)
  1959.             (if (eq (car n) 'TAGBODY)
  1960.                 (progn
  1961.                     (setq found (assoc var (cdr n)))
  1962.                     (if found (return-from find-go-tag found)))))))
  1963.  
  1964. ;;
  1965. ;;    find-go-tag-tagbody
  1966. ;;    Returns the cleanup form for the TAGBODY block which contains the 
  1967. ;;    passed tag.
  1968. ;;
  1969. (defun find-go-tag-tagbody (var)
  1970.     (let (found)
  1971.         (dolist (n *cleanup-forms-stack* nil)
  1972.             (if (eq (car n) 'TAGBODY)
  1973.                 (progn
  1974.                     (setq found (assoc var (cdr n)))
  1975.                     (if found (return-from find-go-tag-tagbody n)))))))
  1976.  
  1977. (defun find-block (name)
  1978.     (dolist (n *cleanup-forms-stack* nil)
  1979.         (if (eq (car n) 'BLOCK)
  1980.             (if (eq (cadr n) name)
  1981.                 (return-from find-block n)))))
  1982.  
  1983. (defun find-any-block ()
  1984.     (dolist (n *cleanup-forms-stack* nil)
  1985.         (if (eq (car n) 'BLOCK)
  1986.             (return-from find-any-block n))))
  1987.  
  1988. (defun parameter-ceiling (n)
  1989.     ;; keep track of how large a parameter frame we need
  1990.     (if (> n *max-call-parameters*)
  1991.         (setq *max-call-parameters* n)))
  1992.  
  1993. ;;
  1994. ;;    required-arguments
  1995. ;;    Returns a list of the required arguments in a lambda list.
  1996. ;;
  1997. (defun required-arguments (lambda-list)
  1998.     (let ((arglist nil))
  1999.         (dolist (n lambda-list)
  2000.             (if (member n *lambda-list-keywords*)
  2001.                 (return)        ;; exit dolist loop
  2002.                 (push n arglist)))
  2003.         (nreverse arglist)))
  2004.  
  2005. ;;
  2006. ;;    optional-arguments
  2007. ;;    Returns a list of the optional arguments in a lambda list.
  2008. ;;
  2009. (defun optional-arguments (lambda-list)
  2010.     (let ((arglist nil))
  2011.         (dolist (n (cdr (member '&optional lambda-list)))
  2012.             (if (member n *lambda-list-keywords*)
  2013.                 (return)        ;; exit dolist loop
  2014.                 (push n arglist)))
  2015.         (nreverse arglist)))
  2016.  
  2017. ;; we don't need this
  2018. ;;
  2019. ;;(defun get-supplied-p-args (lambda-list)    
  2020. ;;    (let ((args nil) (forms (optional-arguments lambda-list)))
  2021. ;;        (dolist (f forms)
  2022. ;;            (if (>= (length f) 3)
  2023. ;;                (push (list (caddr f) nil) args)))
  2024. ;;        (reverse args)))                
  2025.  
  2026. ;;
  2027. ;;    rest-arguments
  2028. ;;    Returns a list of the rest arguments in a lambda list.
  2029. ;;
  2030. (defun rest-arguments (lambda-list)
  2031.     (let ((arglist nil))
  2032.         (dolist (n (cdr (member '&rest lambda-list)))
  2033.             (if (member n *lambda-list-keywords*)
  2034.                 (return)        ;; exit dolist loop
  2035.                 (push n arglist)))
  2036.         (nreverse arglist)))
  2037.         
  2038. ;;
  2039. ;;    key-arguments
  2040. ;;    Returns a list of the optional key in a lambda list.
  2041. ;;
  2042. (defun key-arguments (lambda-list)
  2043.     (let ((arglist nil))
  2044.         (dolist (n (cdr (member '&key lambda-list)))
  2045.             (if (member n *lambda-list-keywords*)
  2046.                 (return)        ;; exit dolist loop
  2047.                 (push n arglist)))
  2048.         (nreverse arglist)))
  2049.         
  2050. ;;
  2051. ;;    aux-arguments
  2052. ;;    Returns a list of the aux arguments in a lambda list.
  2053. ;;
  2054. (defun aux-arguments (lambda-list)
  2055.     (let ((arglist nil))
  2056.         (dolist (n (cdr (member '&aux lambda-list)))
  2057.             (if (member n *lambda-list-keywords*)
  2058.                 (return)        ;; exit dolist loop
  2059.                 (push n arglist)))
  2060.         (nreverse arglist)))
  2061.         
  2062.  
  2063. ;;
  2064. ;;    kill-multiple-values
  2065. ;;    Use this function to make sure that ignored multiple values don't stick
  2066. ;;    around through successive evaluations.
  2067. ;;
  2068. (defun kill-multiple-values ()
  2069.     [
  2070.         `($LOAD-LONG r3 cl::%multiple-values-address)
  2071.         `(li r0 0)
  2072.         `(stw r0 (r3))
  2073.     ])
  2074.  
  2075. (defun compile-nil () 
  2076.     [ `($LOAD-OBJ r28 'nil) ]
  2077.     (setq *last-call-was-values* nil))
  2078.  
  2079. (defun valid-lambda (x)
  2080.     (and (listp x) (> (length x) 2) (eq (car x) 'lambda) (listp (cadr x))))
  2081.  
  2082. (defun find-lambdas (x)
  2083.     (cond ((not (consp x)) nil)
  2084.           ((valid-lambda x) (list x))
  2085.           ((eq (car x) 'FLET) (cadr x))
  2086.           ((eq (car x) 'LABELS) (cadr x))
  2087.           ((eq (car x) 'DEFUN) (list x))
  2088.           ((eq (car x) 'DEFMACRO) (list x))
  2089.           (t (append (find-lambdas (car x)) (find-lambdas (cdr x))))))
  2090.  
  2091. (defun add-lexical-variables (varlist)
  2092.     (push-cleanup (cons 'LET varlist)))
  2093.  
  2094. (defun add-lexical-functions (varlist)
  2095.     (push-cleanup (cons 'FLET varlist)))
  2096.  
  2097. (defun search-lambdas (var lambdas)
  2098.     (cond ((null lambdas) nil)
  2099.           ((eq var lambdas) var)
  2100.           ((atom lambdas) nil)
  2101.           ((search-lambdas var (car lambdas)))
  2102.           ((search-lambdas var (cdr lambdas)))))
  2103.           
  2104. (defun referenced-by-embedded-lambdas (var)
  2105.     (search-lambdas var *embedded-lambdas*))
  2106.  
  2107. (defun create-runtime-bindings ()
  2108.     (if *embedded-lambdas*
  2109.         (dolist (n *cleanup-forms-stack*)
  2110.             (if (or (eq 'LET (car n)) (eq 'FLET (car n)))
  2111.                 (dolist (m (cdr n))
  2112.                     (let* ((sym (car m))
  2113.                            (index (cdr m)))
  2114.                         (if (and (integerp index) 
  2115.                                 (referenced-by-embedded-lambdas sym))
  2116.                             (let ((counter *current-call-index*)) 
  2117.                                 (setf (cdr m) (list index))
  2118.                                 (add-to-environment sym)
  2119.                                 (parameter-ceiling (+ counter 3))
  2120.                                 [
  2121.                                     ;; add a heap binding for the variable
  2122.                                     `($LOAD-OBJ r3 ',sym)
  2123.                                     `(lwz r4 (r30 ,(* index 4)))
  2124.                                     `($CALL #'cl::%cons)
  2125.                                     `(stw r3 (r30 ,(* index 4)))
  2126.  
  2127. #|                                    ;; add a heap binding for the variable
  2128.                                     `($LOAD-OBJ r0 ',sym)
  2129.                                     `(stw r0 (r29 ,(* counter 4)))
  2130.                                     `(lwz r0 (r30 ,(* index 4)))
  2131.                                     `(stw r0 (r29 ,(* (+ counter 1) 4)))
  2132.                                     `(li r0 0)
  2133.                                     `(stw r0 (r29 ,(* (+ counter 2) 4)))
  2134.                                     `(addi r3 r29 ,(* *current-call-index* 4))
  2135.                                     `($CALL #'cl::cons)
  2136.                                     `(stw r3 (r30 ,(* index 4)))
  2137. |#
  2138.                                 ]))))))))
  2139.  
  2140. ;;
  2141. ;;    export-environment()
  2142. ;;    r28 points to the function to receive the environment
  2143. ;;
  2144. (defun export-environment ()
  2145.     ;; first copy our heap environment
  2146.     (let ((counter *current-call-index*)
  2147.           (temp-var1 *lex-counter*)) 
  2148.         (incf *lex-counter*)
  2149.         (parameter-ceiling 3)
  2150.         [
  2151.             `(stw r28 (r29 ,(* counter 4)))            ; target function
  2152.             `(stw r31 (r29 ,(* (+ counter 1) 4)))     ; our environment
  2153.             `(li r0 0)
  2154.             `(stw r0 (r29 ,(* (+ counter 2) 4)))
  2155.             `(addi r3 r29 ,(* *current-call-index* 4))
  2156.             `($CALL #'cl::%function-environment)    ; copy it
  2157.         ]
  2158.         
  2159.         ;; now get the target environment in r3
  2160.         [    
  2161.             `(stw r28 (r29 ,(* counter 4)))            ; target function
  2162.             `(li r0 0)
  2163.             `(stw r0 (r29 ,(* (+ counter 1) 4)))
  2164.             `(addi r3 r29 ,(* *current-call-index* 4))
  2165.             `($CALL #'cl::%function-environment)    ; get its environment
  2166.         ]
  2167.     
  2168.         ;; now add all our current heap bindings
  2169.         (if *embedded-lambdas*
  2170.             (dolist (n *cleanup-forms-stack*)
  2171.                 (if (eq 'LET (car n))
  2172.                     (dolist (m (cdr n))
  2173.                         (let* ((sym (car m)) 
  2174.                                  (index (cdr m)))
  2175.                             (if (consp index)
  2176.                                 [
  2177.                                     ;; add the binding to the target environment
  2178.                                     `(stw r3 (r30 ,(* temp-var1 4))) ; save environment
  2179.                                     `(stw r3 (r29 ,(* counter 4)))     ; environment
  2180.                                     `(lwz r0 (r30 ,(* (car index) 4)))
  2181.                                     `(stw r0 (r29 ,(* (+ counter 1) 4)))
  2182.                                     `(li r0 0)
  2183.                                     `(stw r0 (r29 ,(* (+ counter 2) 4)))
  2184.                                     `(addi r3 r29 ,(* *current-call-index* 4))
  2185.                                     `($CALL #'cl::%environment-add-binding)
  2186.                                     `(lwz r3 (r30 ,(* temp-var1 4))) ; get environment
  2187.                                 ]))))))
  2188.         (if *embedded-lambdas*
  2189.             (dolist (n *cleanup-forms-stack*)
  2190.                 (if (eq 'FLET (car n))
  2191.                     (dolist (m (cdr n))
  2192.                         (let* ((sym (car m)) 
  2193.                                   (index (cdr m)))
  2194.                             (if (consp index)
  2195.                                 [
  2196.                                     ;; add the binding to the target environment
  2197.                                     `(stw r3 (r30 ,(* temp-var1 4))) ; save environment
  2198.                                     `(stw r3 (r29 ,(* counter 4)))     ; environment
  2199.                                     `(lwz r0 (r30 ,(* (car index) 4)))
  2200.                                     `(stw r0 (r29 ,(* (+ counter 1) 4)))
  2201.                                     `(li r0 0)
  2202.                                     `(stw r0 (r29 ,(* (+ counter 2) 4)))
  2203.                                     `(addi r3 r29 ,(* *current-call-index* 4))
  2204.                                     `($CALL #'cl::%environment-add-function-binding)
  2205.                                     `(lwz r3 (r30 ,(* temp-var1 4))) ; get environment
  2206.                                 ]))))))))
  2207.  
  2208.  
  2209. (defun add-to-environment (sym) (push sym *environment*))
  2210. (defun find-in-environment (sym) (member sym *environment*))
  2211. (defun environment-not-empty () *environment* )
  2212.     
  2213. )        ;; close beginning eval-when
  2214.  
  2215.  
  2216.  
  2217.  
  2218.  
  2219.  
  2220.  
  2221.  
  2222.  
  2223.  
  2224.  
  2225.  
  2226.  
  2227.  
  2228.  
  2229.  
  2230.  
  2231.  
  2232.  
  2233.  
  2234.  
  2235.  
  2236.  
  2237.  
  2238.  
  2239.  
  2240.  
  2241.  
  2242.  
  2243.  
  2244.  
  2245.  
  2246.  
  2247.  
  2248.  
  2249.  
  2250.  
  2251.  
  2252.  
  2253.  
  2254.  
  2255.  
  2256.  
  2257.  
  2258.  
  2259.  
  2260.  
  2261.  
  2262.  
  2263.  
  2264.  
  2265.  
  2266.  
  2267.  
  2268.  
  2269.  
  2270.  
  2271.  
  2272.